Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/ptoc/part11

Internet Message Format | 1987-07-28 | 57.1 KB

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i075:  Pascal to C translator, Part11/12
Message-ID: <[e-mail]>
Date: 30 Jul 87 00:31:02 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 2280
Approved: [e-mail]

Submitted-by: Per Bergsten <mcvax!enea!chalmers!holtec!perb>
Posting-number: Volume 10, Issue 75
Archive-name: ptoc/Part11


#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 11 (of 12)."
# Contents:  ptc.p.4
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'ptc.p.4' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'ptc.p.4'\"
else
echo shar: Extracting \"'ptc.p.4'\" \(54467 characters\)
sed "s/^X//" >'ptc.p.4' <<'END_OF_FILE'
X                    end
X            until    tq = nil;
X        555:
X            writeln(';');
X            if tp^.tt = nvarpar then
X                if tp^.tbind^.tt = nconfarr then
X                    begin
X                    indent;
X                    etypedef(tp^.tbind^.tindtyp);
X                    write(tab1);
X                    tq := tp^.tbind^.tcindx^.thi;
X                    printid(tq^.tsym^.lid);
X                    writeln(';')
X                    end;
X            tp := tp^.tnext
X            end
X    end;    (* evar *)
X
X    (*    Emit code for a statment.                *)
X    procedure estmt(tp : treeptr);
X
X    var    tq    : treeptr;
X        locid1,
X        locid2    : idptr;
X        stusd    : boolean;
X        opc1,
X        opc2    : char;
X
X        (*    Emit typename for with-variable.        *)
X        procedure ewithtype(tp : treeptr);
X
X        var    tq    : treeptr;
X
X        begin
X            tq := typeof(tp);
X            write('struct ');
X            printid(tq^.tuid)
X        end;
X
X        (*    Emit code for a case-choise.        *)
X        procedure echoise(tp : treeptr);
X
X        var    tq    : treeptr;
X            i    : integer;
X
X        begin
X            while tp <> nil do
X                begin
X                tq := tp^.tchocon;
X                i := 0;
X                indent;
X                while tq <> nil do
X                    begin
X                    write('  case ');
X                    conflag := true;
X                    eexpr(tq);
X                    conflag := false;
X                    write(':');
X                    i := i + 1;
X                    tq := tq^.tnext;
X                    if (tq = nil) or (i mod 4 = 0) then
X                        begin
X                        writeln;
X                        if tq <> nil then
X                            indent;
X                        i := 0
X                        end
X                    end;
X                increment;
X                if tp^.tchostmt^.tt = nbegin then
X                    estmt(tp^.tchostmt^.tbegin)
X                else
X                    estmt(tp^.tchostmt);
X                indent;
X                writeln('break ;');
X                decrement;
X                tp := tp^.tnext;
X                if tp <> nil then
X                    if tp^.tchocon = nil then
X                        tp := nil
X                end
X        end;    (* echoise *)
X
X        (*    Rename all accessible record-fields to include    *)
X        (*    pointer name.                    *)
X        procedure cenv(ip : idptr; dp : declptr);
X
X        var    tp    : treeptr;
X            sp    : symptr;
X            np    : idptr;
X            h    : hashtyp;
X
X        begin
X            with dp^ do
X              for h := 0 to hashmax - 1 do
X                begin
X                sp := ddecl[h];
X                while sp <> nil do
X                    begin
X                    if sp^.lt = lfield  then
X                        begin
X                        np := sp^.lid;
X                        tp := sp^.lsymdecl^.tup^.tup;
X                        if (tp^.tup^.tt = nvariant) and
X                            (tp^.tuid <> nil) then
X                            np := mkconc('.',
X                                tp^.tuid, np);
X                        np := mkconc('>', ip, np);
X                        sp^.lid := np
X                        end;
X                    sp := sp^.lnext
X                    end
X                end
X        end;    (* cenv *)
X
X        (*    Emit identifiers for push/pop of global ptrs.    *)
X        procedure eglobid(tp : treeptr);
X
X        var    j    : toknidx;
X            w    : toknbuf;
X
X        begin
X            gettokn(tp^.tsym^.lid^.istr, w);
X            j := 1;
X            if w[1] = '*' then
X                j := 2;
X            while w[j] <> chr(null) do
X                begin
X                write(w[j]);
X                j := j + 1
X                end
X        end;
X
X    begin    (* estmt *)
X        while tp <> nil do
X            begin
X            case tp^.tt of
X              nbegin:
X                begin
X                if tp^.tup^.tt in [nbegin, nrepeat,
X                        nproc, nfunc, npgm] then
X                    indent;
X                writeln('{');
X                increment;
X                estmt(tp^.tbegin);
X                decrement;
X                indent;
X                write('}');
X                if tp^.tup^.tt <> nif then
X                    writeln
X                end;
X              nrepeat:
X                begin
X                indent;
X                writeln('do {');
X                increment;
X                estmt(tp^.treptstmt);
X                decrement;
X                indent;
X                write('} while (!(');
X                eexpr(tp^.treptxp);
X                writeln('));')
X                end;
X              nwhile:
X                begin
X                indent;
X                write('while (');
X                increment;
X                eexpr(tp^.twhixp);
X                stusd := setused;
X                if tp^.twhistmt^.tt = nbegin then
X                    begin
X                    decrement;
X                    write(') ');
X                    estmt(tp^.twhistmt)
X                    end
X                else begin
X                    writeln(')');
X                    estmt(tp^.twhistmt);
X                    decrement
X                     end;
X                setused := stusd or setused
X                end;
X              nfor:
X                begin
X                indent;
X                if tp^.tincr then
X                    begin
X                    opc1 := '+';    (* increment variable *)
X                    opc2 := '<'    (* test for <= *)
X                    end
X                else begin
X                    opc1 := '-';    (* decrement variable *)
X                    opc2 := '>';    (* test for >= *)
X                     end;
X                if not lazyfor then
X                    begin
X                    locid1 := mkvariable('B');
X                    locid2 := mkvariable('B');
X                    writeln('{');
X                    increment;
X                    indent;
X                    tq := idup(tp^.tforid);
X                    etypedef(tq^.tbind);
X                    tq := typeof(tq^.tbind);
X                    write(tab1);
X                    printid(locid1);
X                    write(' = ');
X                    eexpr(tp^.tfrom);
X                    writeln(',');
X                    indent;
X                    write(tab1);
X                    printid(locid2);
X                    write(' = ');
X                    eexpr(tp^.tto);
X                    writeln(';');
X                    writeln;
X                    indent;
X                    write('if (');
X                    if tq^.tt = nscalar then
X                        begin
X                        write('(int)(');
X                        printid(locid1);
X                        write(')')
X                        end
X                    else
X                        printid(locid1);
X                    write(' ', opc2, '= ');
X                    if tq^.tt = nscalar then
X                        begin
X                        write('(int)(');
X                        printid(locid2);
X                        write(')')
X                        end
X                    else
X                        printid(locid2);
X                    writeln(')');
X                    increment;
X                    indent;
X                    tp^.tfrom := newid(locid1);
X                    tp^.tfrom^.tup := tp
X                    end;
X                write('for (');
X                increment;
X                eexpr(tp^.tforid);
X                tq := typeof(tp^.tforid);
X                write(' = ');
X                eexpr(tp^.tfrom);
X                write('; ');
X                if lazyfor then
X                    begin
X                    if tq^.tt = nscalar then
X                        begin
X                        write('(int)(');
X                        eexpr(tp^.tforid);
X                        write(')')
X                        end
X                    else
X                        eexpr(tp^.tforid);
X                    write(' ', opc2, '= ');
X                    if tq^.tt = nscalar then
X                        begin
X                        write('(int)(');
X                        eexpr(tp^.tto);
X                        write(')')
X                        end
X                    else
X                        eexpr(tp^.tto)
X                    end;
X                write('; ');
X                eexpr(tp^.tforid);
X                if tq^.tt = nscalar then
X                    begin
X                    write(' = (');
X                    eexpr(tq^.tup^.tidl);
X                    write(')((int)(');
X                    eexpr(tp^.tforid);
X                    write(')', opc1, '1)')
X                    end
X                else
X                    write(opc1, opc1);
X                if not lazyfor then
X                    begin
X                    if tp^.tforstmt^.tt <> nbegin then
X                        begin
X                        (* create compund stmt *)
X                        tq := mknode(nbegin);
X                        tq^.tbegin := tp^.tforstmt;
X                        tq^.tbegin^.tup := tq;
X                        tp^.tforstmt := tq;
X                        tq^.tup := tp
X                        end;
X                    (* find end of loop *)
X                    tq := tp^.tforstmt^.tbegin;
X                    while tq^.tnext <> nil do
X                        tq := tq^.tnext;
X                    (* add break stmt *)
X                    tq^.tnext := mknode(nbreak);
X                    tq := tq^.tnext;
X                    tq^.tup := tp^.tforstmt;
X                    tq^.tbrkid := tp^.tforid;
X                    tq^.tbrkxp := newid(locid2);
X                    tq^.tbrkxp^.tup := tq
X                    end;
X                if tp^.tforstmt^.tt = nbegin then
X                    begin
X                    decrement;
X                    write(') ');
X                    estmt(tp^.tforstmt)
X                    end
X                else begin
X                    writeln(')');
X                    estmt(tp^.tforstmt);
X                    decrement
X                     end;
X                if not lazyfor then
X                    begin
X                    decrement;
X                    decrement;
X                    indent;
X                    writeln('}')
X                    end
X                end;
X              nif:
X                begin
X                indent;
X                write('if (');
X                increment;
X                eexpr(tp^.tifxp);
X                stusd := setused;
X                setused := false;
X                if tp^.tthen^.tt = nbegin then
X                    begin
X                    decrement;
X                    write(') ');
X                    estmt(tp^.tthen);
X                    if tp^.telse <> nil then
X                        write(space)
X                    else
X                        writeln
X                    end
X                else begin
X                    writeln(')');
X                    estmt(tp^.tthen);
X                    decrement;
X                    if tp^.telse <> nil then
X                        indent
X                     end;
X                if tp^.telse <> nil then
X                    begin
X                    write('else');
X                    if tp^.telse^.tt = nbegin then
X                        begin
X                        write(space);
X                        estmt(tp^.telse);
X                        writeln
X                        end
X                    else begin
X                        increment;
X                        writeln;
X                        estmt(tp^.telse);
X                        decrement
X                         end;
X                    end;
X                setused := stusd or setused
X                end;
X              ncase:
X                begin
X                indent;
X                write('switch (');
X                increment;
X                eexpr(tp^.tcasxp);
X                writeln(') {');
X                decrement;
X                echoise(tp^.tcaslst);
X                indent;
X                writeln('  default:');
X                increment;
X                if tp^.tcasother = nil then
X                    begin
X                    indent;
X                    writeln('Caseerror(Line);')
X                    end
X                else
X                    estmt(tp^.tcasother);
X                decrement;
X                indent;
X                writeln('}')
X                end;
X              nwith:
X                begin
X                indent;
X                writeln('{');
X                increment;
X                tq := tp^.twithvar;
X                while tq <> nil do
X                    begin
X                    indent;
X                    write(registr);
X                    ewithtype(tq^.texpw);
X                    write(' *');
X                    locid1 := mkvariable('W');
X                    printid(locid1);
X                    write(' = ');
X                    eaddr(tq^.texpw);
X                    writeln(';');
X                    cenv(locid1, tq^.tenv);
X                    tq := tq^.tnext
X                    end;
X                writeln;
X                if tp^.twithstmt^.tt = nbegin then
X                    estmt(tp^.twithstmt^.tbegin)
X                else
X                    estmt(tp^.twithstmt);
X                decrement;
X                indent;
X                writeln('}')
X                end;
X              ngoto:
X                begin
X                indent;
X                if islocal(tp^.tlabel) then
X                    writeln('goto L',
X                        tp^.tlabel^.tsym^.lno:1, ';')
X                else begin
X                    tq := idup(tp^.tlabel);
X                    writeln('longjmp(J[',    (* LIB *)
X                        tq^.tstat:1, '].jb, ',
X                        tp^.tlabel^.tsym^.lno:1, ');')
X                     end
X                end;
X              nlabstmt:
X                begin
X                decrement;
X                indent;
X                writeln('L', tp^.tlabno^.tsym^.lno:1, ':');
X                increment;
X                estmt(tp^.tstmt)
X                end;
X              nassign:
X                begin
X                indent;
X                eexpr(tp);
X                writeln(';')
X                end;
X              ncall:
X                begin
X                indent;
X                tq := idup(tp^.tcall);
X                if (tq^.tt in [nfunc, nproc]) and
X                        (tq^.tsubstmt <> nil) then
X                    if tq^.tsubstmt^.tt = npredef then
X                        epredef(tq, tp)
X                    else begin
X                        ecall(tp);
X                        writeln(';')
X                         end
X                else begin
X                    ecall(tp);
X                    writeln(';')
X                     end
X                end;
X              npush:
X                begin
X                indent;
X                eglobid(tp^.ttmp);
X                write(' = ');
X                eglobid(tp^.tglob);
X                writeln(';');
X                indent;
X                eglobid(tp^.tglob);
X                write(' = ');
X                if tp^.tloc^.tt = nid then
X                    begin
X                    tq := idup(tp^.tloc);
X                    if tq^.tt in [nparproc, nparfunc] then
X                        printid(tp^.tloc^.tsym^.lid)
X                    else
X                        eaddr(tp^.tloc)
X                    end
X                else
X                    eaddr(tp^.tloc);
X                writeln(';')
X                end;
X              npop:
X                begin
X                indent;
X                eglobid(tp^.tglob);
X                write(' = ');
X                eglobid(tp^.ttmp);
X                writeln(';')
X                end;
X              nbreak:
X                begin
X                indent;
X                write('if (');
X                eexpr(tp^.tbrkid);
X                write(' == ');
X                eexpr(tp^.tbrkxp);
X                writeln(') break;')
X                end;
X              nempty:
X                if not (tp^.tup^.tt in [npgm, nproc, nfunc,
X                        nchoise, nbegin, nrepeat]) then
X                    begin
X                    indent;
X                    writeln(';')
X                    end
X            end;(* case *)
X            if setused and
X                (tp^.tup^.tt in [npgm, nproc, nfunc, nrepeat,
X                        nbegin, nchoise, nwith]) then
X                begin
X                indent;
X                writeln('Claimset();');
X                setused := false
X                end;
X            tp := tp^.tnext
X            end
X    end;    (* estmt *)
X
X    (*    Emit initialization for non-local gotos.        *)
X    procedure elabel(tp : treeptr);
X
X    var    tq    : treeptr;
X        i    : integer;
X
X    begin
X        i := 0;
X        tq := tp^.tsublab;
X        while tq <> nil do
X            begin
X            if tq^.tsym^.lgo then
X                i := i + 1;
X            tq := tq^.tnext
X            end;
X        if i =1 then
X            begin
X            tq := tp^.tsublab;
X            while not tq^.tsym^.lgo do
X                tq := tq^.tnext;
X            indent;
X            writeln('if (',
X                'setjmp(J[', tp^.tstat:1, '].jb))'); (* LIB *)
X            writeln(tab1, 'goto L', tq^.tsym^.lno:1, ';')
X            end
X        else if i > 1 then
X            begin
X            indent;
X            writeln('switch (',
X                'setjmp(J[', tp^.tstat:1, '].jb)) {'); (* LIB *)
X            indent;
X            writeln('  case 0:');
X            indent;
X            writeln(tab1, 'break');
X            tq := tp^.tsublab;
X            while tq <> nil do
X                begin
X                if tq^.tsym^.lgo then
X                    begin
X                    (* label used in non-local goto *)
X                    indent;
X                    writeln('  case ',
X                            tq^.tsym^.lno:1, ':');
X                    indent;
X                    writeln(tab1, 'goto L',
X                            tq^.tsym^.lno:1, ';')
X                    end;
X                tq := tq^.tnext
X                end;
X            indent;
X            writeln('  default:');
X            indent;
X            writeln(tab1, 'Caseerror(Line)');
X            indent;
X            writeln('}')
X            end
X    end;    (* elabel *)
X
X    (*    Emit declaration for lower bound of conformant array.    *)
X    procedure econf(tp : treeptr);
X
X    var    tq    : treeptr;
X
X    begin
X        while tp <> nil do
X            begin
X            if tp^.tt = nvarpar then
X                if tp^.tbind^.tt = nconfarr then
X                    begin
X                    indent;
X                    etypedef(tp^.tbind^.tindtyp);
X                    write(tab1);
X                    tq := tp^.tbind^.tcindx^.tlo;
X                    printid(tq^.tsym^.lid);
X                    write(' = (');
X                    etypedef(tp^.tbind^.tindtyp);
X                    writeln(')0;')
X                    end;
X            tp := tp^.tnext
X            end
X    end;    (* econf *)
X
X    (*    Emit code for subroutines.                *)
X    procedure esubr(tp : treeptr);
X
X    label    999;
X
X    var    tq, ti    : treeptr;
X
X    begin
X        while tp <> nil do
X            begin
X            (* emit nested subroutines *)
X            if tp^.tsubsub <> nil then
X                begin
X                (* emit forward declaration of this subroutine
X                   in case of recursion *)
X                etypedef(tp^.tfuntyp);
X                write(space);
X                printid(tp^.tsubid^.tsym^.lid);
X                writeln('();');
X                writeln;
X                esubr(tp^.tsubsub)
X                end;
X            (* emit this subroutine *)
X            if tp^.tsubstmt = nil then
X                begin
X                (* forward/external decl *)
X                if tp^.tsubid^.tsym^.lsymdecl^.tup = tp then
X                    write(xtern);
X                etypedef(tp^.tfuntyp);
X                write(space);
X                printid(tp^.tsubid^.tsym^.lid);
X                writeln('();');
X                goto 999
X                end;
X            write(space);
X            etypedef(tp^.tfuntyp);
X            writeln;
X            printid(tp^.tsubid^.tsym^.lid);
X            write('(');
X            tq := tp^.tsubpar;
X            while tq <> nil do
X                begin
X                case tq^.tt of
X                  nvarpar,
X                  nvalpar:
X                    begin
X                    ti := tq^.tidl;
X                    while ti <> nil do
X                        begin
X                        printid(ti^.tsym^.lid);
X                        ti := ti^.tnext;
X                        if ti <> nil then
X                            write(', ');
X                        end;
X                    if tq^.tbind^.tt = nconfarr then
X                        begin
X                        (* add upper bound parameter *)
X                        ti := tq^.tbind^.tcindx^.thi;
X                        write(', ');
X                        printid(ti^.tsym^.lid)
X                        end;
X                    end;
X                  nparproc,
X                  nparfunc:
X                    begin
X                    ti := tq^.tparid;
X                    printid(ti^.tsym^.lid)
X                    end
X                end;(* case *)
X                tq := tq^.tnext;
X                if tq <> nil then
X                    write(', ');
X                end;
X            writeln(')');
X            increment;
X            evar(tp^.tsubpar);
X            writeln('{');
X            econf(tp^.tsubpar);
X            econst(tp^.tsubconst);
X            etype(tp^.tsubtype);
X            evar(tp^.tsubvar);
X
X            if (tp^.tsubconst <> nil) or (tp^.tsubtype <> nil) or
X                    (tp^.tsubvar <> nil) then
X                writeln;
X            elabel(tp);
X            estmt(tp^.tsubstmt);
X            if tp^.tt = nfunc then
X                begin
X                (* return value in the FIRST variable,
X                   see renamf() above *)
X                indent;
X                write('return ');
X                printid(tp^.tsubvar^.tidl^.tsym^.lid);
X                writeln(';');
X                end;
X            decrement;
X            writeln('}');
X        999:
X            writeln;
X            tp := tp^.tnext
X            end
X    end;    (* esubr *)
X
X    function use(d : predefs) : boolean;
X
X    begin
X        use := defnams[d]^.lused
X    end;
X
X    (*    Emit code for main program.                *)
X    procedure eprogram(tp : treeptr);
X
X        (*    Symbol that sp refers to is renamed if it has    *)
X        (*    been redefined in source program.        *)
X        procedure capital(sp : symptr);
X
X        var    tb    : toknbuf;
X
X        begin
X            if sp^.lid^.inref > 1 then
X                begin
X                gettokn(sp^.lid^.istr, tb);
X                tb[1] := uppercase(tb[1]);
X                sp^.lid := saveid(tb)
X                end
X        end;
X
X        procedure etextdef;
X
X        var    tq    : treeptr;
X
X        begin
X            write('typedef ');
X            tq := mknode(nfileof);
X            tq^.tof := typnods[tchar];
X            etypedef(tq);
X            writeln(tab1, 'text;')
X        end;
X
X    begin    (* eprogram *)
X        if tp^.tsubid <> nil then
X            begin
X            (* program heading was seen *)
X            writeln('/', '*');
X            write('**    Code derived from program ');
X            printid(tp^.tsubid^.tsym^.lid);
X            writeln;
X            writeln('*', '/');
X            writeln(xtern, voidtyp, tab1, 'exit();')
X            end;
X        if usecase or usesets or
X           use(dinput) or use(doutput) or
X           use(dwrite) or use(dwriteln) or use(dmessage) or
X           use(deof) or use(deoln) or use(dflush) or use(dpage) or
X           use(dread) or use(dreadln) or use(dclose) or
X           use(dreset) or use(drewrite) or use(dget) or use(dput) then
X            begin
X            writeln('/', '*');
X            writeln('**    Definitions for i/o');
X            writeln('*', '/');
X            writeln(include, '<stdio.h>')    (* LIB *)
X            end;
X        if use(dinput) or use(doutput) or use(dtext) then
X            begin
X            etextdef;
X            if use(dinput) then
X                begin
X                if tp^.tsubid = nil then
X                    write(xtern);
X                write('text', tab1);
X                printid(defnams[dinput]^.lid);
X                if tp^.tsubid <> nil then
X                    write(' = { stdin, 0, 0 }');
X                writeln(';')
X                end;
X            if use(doutput) then
X                begin
X                if tp^.tsubid = nil then
X                    write(xtern);
X                write('text', tab1);
X                printid(defnams[doutput]^.lid);
X                if tp^.tsubid <> nil then
X                    write(' = { stdout, 0, 0 }');
X                writeln(';')
X                end
X            end;
X        if use(dinput) or use(dget) or use(dread) or use(dreadln) or
X           use(deof) or use(deoln) or use(dreset) or use(drewrite) then
X            begin
X            writeln(define, 'Fread(x, f) ',
X                'fread((char *)&x, sizeof(x), 1, f)'); (* LIB *)
X            writeln(define, 'Get(f) Fread((f).buf, (f).fp)');
X            writeln(define, 'Getx(f) (f).init = 1, ',
X                '(f).eoln = (((f).buf = ',
X                    'fgetc((f).fp)',    (* LIB *)
X                    ') == ', nlchr, ') ? (((f).buf = ',
X                        spchr, '), 1) : 0');
X            writeln(define, 'Getchr(f) (f).buf, Getx(f)')
X            end;
X        if use(dread) or use(dreadln) then
X            begin
X            writeln(static, 'FILE', tab1, '*Tmpfil;');
X            writeln(static, 'long', tab1, 'Tmplng;');
X            writeln(static, 'double', tab1, 'Tmpdbl;');
X            writeln(define, 'Fscan(f) (f).init ? ',
X                'ungetc((f).buf, (f).fp)',    (* LIB *)
X                    ' : 0, Tmpfil = (f).fp');
X            writeln(define, 'Scan(p, a) ',
X                'Scanck(fscanf(Tmpfil, p, a))'); (* LIB *)
X            writeln(voidtyp, tab1, 'Scanck();');
X            if use(dreadln) then
X                writeln(voidtyp, tab1, 'Getl();');
X            end;
X        if use(deoln) then
X            writeln(define, 'Eoln(f) ((f).eoln ? true : false)');
X        if use(deof) then
X            writeln(define, 'Eof(f) ',
X                '((((f).init == 0) ? (Get(f)) : 0, ',
X                    '((f).eof ? 1 : ',
X                        'feof((f).fp))) ? ', (* LIB *)
X                            'true : false)');
X        if use(doutput) or use(dput) or
X                use(dwrite) or use(dwriteln) or
X                use(dreset) or use(drewrite) or use(dclose) then
X            begin
X            writeln(define, 'Fwrite(x, f) ',
X                'fwrite((char *)&x, sizeof(x), 1, f)');(* LIB *)
X            writeln(define, 'Put(f) Fwrite((f).buf, (f).fp)');
X            writeln(define, 'Putx(f) (f).eoln = ((f).buf == ',
X                nlchr, '), ', voidcast,
X                'fputc((f).buf, (f).fp)'); (* LIB *)
X            writeln(define, 'Putchr(c, f) (f).buf = (c), Putx(f)');
X            writeln(define, 'Putl(f, v) (f).eoln = v')
X            end;
X        if use(dreset) or use(drewrite) or use(dclose) then
X            writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ',
X                '(Putchr(', nlchr, ', f), 0) : 0, ',
X                    'rewind((f).fp)');    (* LIB *)
X        if use(dclose) then
X            begin
X            writeln(define, 'Close(f) (f).init = ',
X                '((f).init ? (',
X                    'fclose((f).fp), ',    (* LIB *)
X                        '0) : 0), (f).fp = NULL');
X            writeln(define, 'Closex(f) (f).init = ',
X                '((f).init ? ',
X                    '(Finish(f), ',
X                    'fclose((f).fp), ',    (* LIB *)
X                        '0) : 0), (f).fp = NULL')
X            end;
X        if use(dreset) then
X            begin
X            writeln(ifdef, 'READONLY');
X            writeln(static, chartyp, tab1, 'Rmode[] = "r";');
X            writeln(elsif);
X            writeln(static, chartyp, tab1, 'Rmode[] = "r+";');
X            writeln(endif);
X            writeln(define, 'Reset(f, n) (f).init = ',
X                '(f).init ? rewind((f).fp) : ',    (* LIB *)
X                '(((f).fp = Fopen(n, Rmode)), 1), ',
X                    '(f).eof = (f).out = 0, Get(f)');
X            writeln(define, 'Resetx(f, n) (f).init = ',
X                '(f).init ? (Finish(f)) : ',
X                '(((f).fp = Fopen(n, Rmode)), 1), ',
X                    '(f).eof = (f).out = 0, Getx(f)');
X            usefopn := true
X            end;
X        if use(drewrite) then
X            begin
X            writeln(ifdef, 'WRITEONLY');
X            writeln(static, chartyp, tab1, 'Wmode[] = "w";');
X            writeln(elsif);
X            writeln(static, chartyp, tab1, 'Wmode[] = "w+";');
X            writeln(endif);
X            writeln(define, 'Rewrite(f, n) (f).init = ',
X                '(f).init ? rewind((f).fp) : ',    (* LIB *)
X                '(((f).fp = Fopen(n, Wmode)), 1), ',
X                    '(f).out = (f).eof = 1');
X            writeln(define, 'Rewritex(f, n) (f).init = ',
X                '(f).init ? (Finish(f)) : ',
X                '(((f).fp = Fopen(n, Wmode)), 1), ',
X                    '(f).out = (f).eof = (f).eoln = 1');
X            usefopn := true
X            end;
X        if usefopn then
X            begin
X            writeln('FILE    *Fopen();');
X            writeln(define, 'MAXFILENAME 256')
X            end;
X        if usecase or usejmps then
X            begin
X            writeln('/', '*');
X            writeln('**    Definitions for case-statements');
X            writeln('**    and for non-local gotos');
X            writeln('*', '/');
X            writeln(define, 'Line __LINE__');
X            writeln(voidtyp, tab1, 'Caseerror();')
X            end;
X        if usejmps then
X            begin
X            writeln(include, '<setjmp.h>');    (* LIB *)
X            writeln(static, 'struct Jb { jmp_buf', tab1, 'jb; } J[',
X                            (maxlevel+1):1, '];')
X            end;
X        if use(dinteger) or use(dmaxint) or
X            use(dboolean) or use(dfalse) or use(dtrue) or
X                use(deof) or use(deoln) or use(dexp) or
X                use(dln) or use(dsqr) or use(dsin) or
X                use(dcos) or use(dtan) or use(darctan) or
X                use(dsqrt) or use(dreal) then
X            begin
X            writeln('/', '*');
X            writeln('**    Definitions for standard types');
X            writeln('*', '/')
X            end;
X        if usecomp then
X            begin
X            writeln(xtern, inttyp, ' strncmp();');    (* LIB *)
X            writeln(define,
X                'Cmpstr(x, y) ',
X                'strncmp((x), (y), sizeof(x))')    (* LIB *)
X            end;
X        if use(dboolean) or use(dfalse) or use(dtrue) or
X            use(deof) or use(deoln) or usesets then
X            begin
X            capital(defnams[dboolean]);
X            write(typdef, chartyp, tab1);
X            printid(defnams[dboolean]^.lid);
X            writeln(';');
X            capital(defnams[dfalse]);
X            write(define);
X            printid(defnams[dfalse]^.lid);
X            write(' (');
X            printid(defnams[dboolean]^.lid);
X            writeln(')0');
X            capital(defnams[dtrue]);
X            write(define);
X            printid(defnams[dtrue]^.lid);
X            write(' (');
X            printid(defnams[dboolean]^.lid);
X            writeln(')1');
X            writeln(xtern, chartyp, tab1, '*Bools[];')
X            end;
X        capital(defnams[dinteger]);
X        if use(dinteger) then
X            begin
X            write(typdef, inttyp, tab1);
X            printid(defnams[dinteger]^.lid);
X            writeln(';')
X            end;
X        if use(dmaxint) then
X            writeln(define, 'maxint', tab1, maxint:1);
X        capital(defnams[dreal]);
X        if use(dreal) then
X            begin
X            write(typdef, realtyp, tab1);
X            printid(defnams[dreal]^.lid);
X            writeln(';')
X            end;
X        if use(dexp) then
X            writeln(xtern, doubletyp, ' exp();');    (* LIB *)
X        if use(dln) then
X            writeln(xtern, doubletyp, ' log();');    (* LIB *)
X        if use(dsqr) then
X            writeln(xtern, doubletyp, ' pow();');    (* LIB *)
X        if use(dsin) then
X            writeln(xtern, doubletyp, ' sin();');    (* LIB *)
X        if use(dcos) then
X            writeln(xtern, doubletyp, ' cos();');    (* LIB *)
X        if use(dtan) then
X            writeln(xtern, doubletyp, ' tan();');    (* LIB *)
X        if use(darctan) then
X            writeln(xtern, doubletyp, ' atan();');    (* LIB *)
X        if use(dsqrt) then
X            writeln(xtern, doubletyp, ' sqrt();');    (* LIB *)
X        if use(dabs) and use(dreal) then
X            writeln(xtern, doubletyp, ' fabs();');    (* LIB *)
X        if use(dhalt) then
X            writeln(xtern, voidtyp, ' abort();');    (* LIB *)
X        if use(dnew) or usenilp then
X            begin
X            writeln('/', '*');
X            writeln('**    Definitions for pointers');
X            writeln('*', '/');
X            end;
X        if use(dnew) then
X            begin
X            writeln(ifndef, 'Unionoffs');
X            writeln(define, 'Unionoffs(p, m) ',
X                '(((long)(&(p)->m))-((long)(p)))');    (* CPU *)
X            writeln(endif)
X            end;
X        if usenilp then
X            writeln(define, 'NIL 0');        (* CPU *)
X        if use(dnew) then
X            writeln(xtern, chartyp, ' *malloc();');    (* LIB *)
X        if use(ddispose) then
X            writeln(xtern, voidtyp, ' free();');    (* LIB *)
X        if usesets then
X            begin
X            writeln('/', '*');
X            writeln('**    Definitions for set-operations');
X            writeln('*', '/');
X            writeln(define, 'Claimset() ',
X                voidcast, 'Currset(0, (', setptyp, ')0)');
X            writeln(define, 'Newset() ',
X                    'Currset(1, (', setptyp, ')0)');
X            writeln(define, 'Saveset(s) Currset(2, s)');
X            writeln(define, 'setbits ', setbits:1);
X            writeln(typdef, wordtype, tab1, setwtyp, ';');
X            writeln(typdef, setwtyp, ' *', tab1, setptyp, ';');
X            printid(defnams[dboolean]^.lid);
X            writeln(tab1, 'Member(), Le(), Ge(), Eq(), Ne();');
X            writeln(setptyp, tab1, 'Union(), Diff();');
X            writeln(setptyp, tab1, 'Insmem(), Mksubr();');
X            writeln(setptyp, tab1, 'Currset(), Inter();');
X            writeln(static, setptyp, tab1, 'Tmpset;');
X            writeln(xtern, setptyp, tab1, 'Conset[];');
X            writeln(voidtyp, tab1, 'Setncpy();')
X            end;
X        writeln(xtern, chartyp, ' *strncpy();');    (* LIB *)
X        if use(dargc) or use(dargv) then
X            begin
X            writeln('/', '*');
X            writeln('**    Definitions for argv-operations');
X            writeln('*', '/');
X            writeln(inttyp, tab1, 'argc;');        (* OS *)
X            writeln(chartyp, tab1, '**argv;');
X            writeln(' void');
X            writeln('Argvgt(n, cp, l)');
X            writeln(inttyp, tab1, 'n;');
X            writeln(registr, inttyp, tab1, 'l;');
X            writeln(registr, chartyp, tab1, '*cp;');
X            writeln('{');
X            writeln(tab1, registr, chartyp, tab1, '*sp;');
X            writeln;
X            writeln(tab1, 'for (sp = argv[n]; l > 0 && *sp; l--)');
X            writeln(tab2, '*cp++ = *sp++;');
X            writeln(tab1, 'while (l-- > 0)');
X            writeln(tab2, '*cp++ = ', spchr, ';');
X            writeln('}');
X            end;
X        if (tp^.tsubconst <> nil) or (tp^.tsubtype<> nil) or
X            (tp^.tsubvar <> nil) or (tp^.tsubsub <> nil) then
X            begin
X            writeln('/', '*');
X            writeln('**    Start of program definitions');
X            writeln('*', '/');
X            end;
X        econst(tp^.tsubconst);
X        etype(tp^.tsubtype);
X        evar(tp^.tsubvar);
X        if tp^.tsubsub <> nil then
X            writeln;
X        esubr(tp^.tsubsub);
X        if tp^.tsubid <> nil then
X            begin
X            (* program heading was seen *)
X            writeln('/', '*');
X            writeln('**    Start of program code');
X            writeln('*', '/');
X            if use(dargc) or use(dargv) then
X                begin
X                writeln('main(_ac, _av)');    (* OS *)
X                writeln(inttyp, tab1, '_ac;');
X                writeln(chartyp, tab1, '*_av[];');
X                writeln('{');
X                writeln;
X                writeln(tab1, 'argc = _ac;');
X                writeln(tab1, 'argv = _av;')
X                end
X            else begin
X                writeln('main()');
X                writeln('{')
X                 end;
X            increment;
X            elabel(tp);
X            estmt(tp^.tsubstmt);
X            indent;
X            writeln('exit(0);');
X            decrement;
X            writeln('}');
X            writeln('/', '*');
X            writeln('**    End of program code');
X            writeln('*', '/')
X            end
X    end;    (* eprogram *)
X
X    (*    Emit definitions for constant sets    *)
X    procedure econset(tp : treeptr; len : integer);
X
X    var    i    : integer;
X
X        function size(tp : treeptr) : integer;
X
X        var    r, x    : integer;
X
X        begin
X            r := 0;
X            while tp <> nil do
X                begin
X                if tp^.tt = nrange then
X                    x := cvalof(tp^.texpr)
X                else if tp^.tt = nempty then
X                    x := 0
X                else
X                    x := cvalof(tp);
X                if x > r then
X                    r := x;
X                tp := tp^.tnext
X                end;
X            size := csetwords(r+1)
X        end;
X
X        (*    Emit bits in a constant set    *)
X        procedure ebits(tp : treeptr);
X
X        type    bitset    = set of 0 .. setbits;
X
X        var    sets    : array [ 0 .. maxsetrange ] of bitset;
X            s, m, n    : integer;
X
X            procedure eword(s : bitset);
X
X            const    bitshex    = 4;    (* nr of bits in a hex-digit *)
X
X            var    n, i    : integer;
X                x    : 0 .. setbits;
X
X            begin
X                n := 0;
X                while n <= setbits do
X                    n := n + bitshex;
X                n := n - bitshex;
X                while n >= 0 do
X                    begin
X                    (* compute 1 hexdigit *)
X                    x := 0;
X                    for i := 0 to bitshex - 1 do
X                        if (n + i) in s then
X                            case i of
X                              0:    x := x + 1;
X                              1:    x := x + 2;
X                              2:    x := x + 4;
X                              3:    x := x + 8
X                            end;(* case *)
X                    (* print it *)
X                    write(hexdig[x]);
X                    n := n - bitshex
X                    end
X            end;
X
X        begin
X            s := size(tp);
X            for n := 0 to s - 1 do
X                sets[n] := [];
X            while tp <> nil do
X                begin
X                if tp^.tt = nrange then
X                    for m := cvalof(tp^.texpl) to
X                            cvalof(tp^.texpr) do
X                        begin
X                        n := m div (setbits+1);
X                        sets[n] := sets[n] +
X                            [m mod (setbits+1)]
X                        end
X                else if tp^.tt <> nempty then
X                    begin
X                    m := cvalof(tp);
X                    n := m div (setbits+1);
X                    sets[n] := sets[n] +
X                        [m mod (setbits+1)]
X                    end;
X                tp := tp^.tnext
X                end;
X            write(tab1, s:1);
X            for n := 0 to s - 1 do
X                begin
X                write(',');
X                if n mod 6 = 0 then
X                    writeln;
X                write(tab1, '0x');
X                eword(sets[n]);
X                end;
X            writeln
X        end;
X
X    begin
X        i := 0;
X        while tp <> nil do
X            begin
X            writeln(static, setwtyp, tab1, 'Q', i:1, '[] = {');
X            ebits(tp^.texps);
X            writeln('};');
X            i := i + 1;
X            tp := tp^.tnext
X            end;
X        writeln(static, setwtyp, tab1, '*Conset[] = {');
X        for i := len - 1 downto 1 do
X            begin
X            write(tab1, 'Q', i:1, ',');
X            if i mod 6 = 5 then
X                writeln
X            end;
X        writeln(tab1, 'Q0');
X        writeln('};');
X    end;
X
Xbegin    (* emit *)
X    indnt := 0;
X    varno := 0;
X    conflag := false;
X    setused := false;
X    dropset := false;
X    doarrow := 0;
X    eprogram(top);
X    if usebool then
X        writeln(chartyp, tab1, '*Bools[] = { "false", "true" };');
X    if usescan then
X        begin
X        writeln;
X        writeln(static, voidtyp);
X        writeln('Scanck(n)');
X        writeln(inttyp, tab1, 'n;');
X        writeln('{');
X        writeln(tab1, 'if (n != 1) {');
X        writeln(tab2, voidcast, 'fprintf(stderr, "Bad input\n");');
X        writeln(tab2, 'exit(1);');
X        writeln(tab1, '}');
X        writeln('}')
X        end;
X    if usegetl then
X        begin
X        writeln;
X        writeln(static, voidtyp);
X        writeln('Getl(f)');
X        writeln(' text', tab1, '*f;');
X        writeln('{');
X        writeln(tab1, 'while (f->eoln == 0)');
X        writeln(tab2, 'Getx(*f);');
X        writeln(tab1, 'Getx(*f);');
X        writeln('}')
X        end;
X    if usefopn then
X        begin
X        writeln;
X        writeln(static, 'FILE *');
X        writeln('Fopen(n, m)');
X        writeln(chartyp, tab1, '*n, *m;');
X        writeln('{');
X        writeln(tab1, 'FILE', tab2, '*f;');
X        writeln(tab1, registr, chartyp, tab1, '*s;');
X        writeln(tab1, static, chartyp, tab1, 'ch = ',
X                        quote, 'A', quote, ';');
X        writeln(tab1, static, chartyp, tab1, 'tmp[MAXFILENAME];');
X        writeln(tab1, xtern , inttyp, tab1, 'unlink();'); (* OS *)
X        writeln;
X        writeln(tab1, 'if (n == NULL)');
X        writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);');
X        writeln(tab1, 'else {');
X        writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));');
X        writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ',
X            spchr, ' || *s == ', nulchr, '; )');
X        writeln(tab3, '*s-- = ', nulchr, ';');
X        writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {');
X        writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ',
X            quote, '%s', quote, '\n", n);');
X        writeln(tab3, 'exit(1);');
X        writeln(tab2, '}');
X        writeln(tab1, '}');
X        writeln(tab1, 's = tmp;');
X        writeln(tab1, 'if ((f = fopen(s, m)) == NULL) {');
X        writeln(tab2, voidcast,
X                'fprintf(stderr, "Cannot open: %s\n", s);');
X        writeln(tab2, 'exit(1);');
X        writeln(tab1, '}');
X        writeln(tab1, 'if (n == NULL)');
X        writeln(tab2, 'unlink(tmp);');    (* OS *)
X        writeln(tab1, 'return (f);');
X        writeln('}');
X        writeln(xtern, inttyp, tab1, 'rewind();')
X        end;
X    if setcnt > 0 then
X        econset(setlst, setcnt);
X    if useunion then
X        begin
X        writeln;
X        writeln(static, setptyp);
X        writeln('Union(p1, p2)');
X        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X        writeln('{');
X        writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
X        writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
X        writeln(tab4, 'p3 = sp;');
X        writeln;
X        writeln(tab1, 'j = *p1;');
X        writeln(tab1, '*p3 = j;');
X        writeln(tab1, 'if (j > *p2)');
X        writeln(tab2, 'j = *p2;');
X        writeln(tab1, 'else');
X        writeln(tab2, '*p3 = *p2;');
X        writeln(tab1, 'k = *p1 - *p2;');
X        writeln(tab1, 'p1++, p2++, p3++;');
X        writeln(tab1, 'for (i = 0; i < j; i++)');
X        writeln(tab2, '*p3++ = (*p1++ | *p2++);');
X        writeln(tab1, 'while (k > 0) {');
X        writeln(tab2, '*p3++ = *p1++;');
X        writeln(tab2, 'k--;');
X        writeln(tab1, '}');
X        writeln(tab1, 'while (k < 0) {');
X        writeln(tab2, '*p3++ = *p2++;');
X        writeln(tab2, 'k++;');
X        writeln(tab1, '}');
X        writeln(tab1, 'return (Saveset(sp));');
X        writeln('}')
X        end;
X    if usediff then
X        begin
X        writeln;
X        writeln(static, setptyp);
X        writeln('Diff(p1, p2)');
X        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X        writeln('{');
X        writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
X        writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
X        writeln(tab4, 'p3 = sp;');
X        writeln;
X        writeln(tab1, 'j = *p1;');
X        writeln(tab1, '*p3 = j;');
X        writeln(tab1, 'if (j > *p2)');
X        writeln(tab2, 'j = *p2;');
X        writeln(tab1, 'k = *p1 - *p2;');
X        writeln(tab1, 'p1++, p2++, p3++;');
X        writeln(tab1, 'for (i = 0; i < j; i++)');
X        writeln(tab2, '*p3++ = (*p1++ & ~ (*p2++));');
X        writeln(tab1, 'while (k > 0) {');
X        writeln(tab2, '*p3++ = *p1++;');
X        writeln(tab2, 'k--;');
X        writeln(tab1, '}');
X        writeln(tab1, 'return (Saveset(sp));');
X        writeln('}')
X        end;
X    if useintr then
X        begin
X        writeln;
X        writeln(static, setptyp);
X        writeln('Inter(p1, p2)');
X        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X        writeln('{');
X        writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
X        writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
X        writeln(tab4, 'p3 = sp;');
X        writeln;
X        writeln(tab1, 'if ((j = *p1) > *p2)');
X        writeln(tab2, 'j = *p2;');
X        writeln(tab1, '*p3 = j;');
X        writeln(tab1, 'p1++, p2++, p3++;');
X        writeln(tab1, 'for (i = 0; i < j; i++)');
X        writeln(tab2, '*p3++ = (*p1++ & *p2++);');
X        writeln(tab1, 'return (Saveset(sp));');
X        writeln('}')
X        end;
X    if usememb then
X        begin
X        writeln;
X        write(static);
X        printid(defnams[dboolean]^.lid);
X        writeln;
X        writeln('Member(m, sp)');
X        writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
X        writeln(tab1, registr, setptyp, tab1, 'sp;');
X        writeln('{');
X        writeln(tab1, registr, usigned, inttyp,
X                    tab1, 'i = m / (setbits+1) + 1;');
X        writeln;
X        writeln(tab1, 'if ((i <= *sp) &&',
X                    ' (sp[i] & (1 << (m % (setbits+1)))))');
X        write(tab2, 'return (');
X        printid(defnams[dtrue]^.lid);
X        writeln(');');
X        write(tab1, 'return (');
X        printid(defnams[dfalse]^.lid);
X        writeln(');');
X        writeln('}')
X        end;
X    if useseq or usesne then
X        begin
X        writeln;
X        write(static);
X        printid(defnams[dboolean]^.lid);
X        writeln;
X        writeln('Eq(p1, p2)');
X        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X        writeln('{');
X        writeln(tab1, registr, inttyp, tab1, 'i, j;');
X        writeln;
X        writeln(tab1, 'i = *p1++;');
X        writeln(tab1, 'j = *p2++;');
X        writeln(tab1, 'while (i != 0 && j != 0) {');
X        writeln(tab2, 'if (*p1++ != *p2++)');
X        write(tab3, 'return (');
X        printid(defnams[dfalse]^.lid);
X        writeln(');');
X        writeln(tab2, 'i--, j--;');
X        writeln(tab1, '}');
X        writeln(tab1, 'while (i != 0) {');
X        writeln(tab2, 'if (*p1++ != 0)');
X        write(tab3, 'return (');
X        printid(defnams[dfalse]^.lid);
X        writeln(');');
X        writeln(tab2, 'i--;');
X        writeln(tab1, '}');
X        writeln(tab1, 'while (j != 0) {');
X        writeln(tab2, 'if (*p2++ != 0)');
X        write(tab3, 'return (');
X        printid(defnams[dfalse]^.lid);
X        writeln(');');
X        writeln(tab2, 'j--;');
X        writeln(tab1, '}');
X        write(tab1, 'return (');
X        printid(defnams[dtrue]^.lid);
X        writeln(');');
X        writeln('}')
X        end;
X    if usesne then
X        begin
X        writeln;
X        write(static);
X        printid(defnams[dboolean]^.lid);
X        writeln;
X        writeln('Ne(p1, p2)');
X        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X        writeln('{');
X        write(tab1, 'return (!Eq(p1, p2));');
X        writeln('}')
X        end;
X    if usesle then
X        begin
X        writeln;
X        write(static);
X        printid(defnams[dboolean]^.lid);
X        writeln;
X        writeln('Le(p1, p2)');
X        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X        writeln('{');
X        writeln(tab1, registr, inttyp, tab1, 'i, j;');
X        writeln;
X        writeln(tab1, 'i = *p1++;');
X        writeln(tab1, 'j = *p2++;');
X        writeln(tab1, 'while (i != 0 && j != 0) {');
X        writeln(tab2, 'if ((*p1++ & ~ *p2++) != 0)');
X        write(tab3, 'return (');
X        printid(defnams[dfalse]^.lid);
X        writeln(');');
X        writeln(tab2, 'i--, j--;');
X        writeln(tab1, '}');
X        writeln(tab1, 'while (i != 0) {');
X        writeln(tab2, 'if (*p1++ != 0)');
X        write(tab3, 'return (');
X        printid(defnams[dfalse]^.lid);
X        writeln(');');
X        writeln(tab2, 'i--;');
X        writeln(tab1, '}');
X        write(tab1, 'return (');
X        printid(defnams[dtrue]^.lid);
X        writeln(');');
X        writeln('}')
X        end;
X    if usesge then
X        begin
X        writeln;
X        write(static);
X        printid(defnams[dboolean]^.lid);
X        writeln;
X        writeln('Ge(p1, p2)');
X        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
X        writeln('{');
X        writeln(tab1, registr, inttyp, tab1, 'i, j;');
X        writeln;
X        writeln(tab1, 'i = *p1++;');
X        writeln(tab1, 'j = *p2++;');
X        writeln(tab1, 'while (i != 0 && j != 0) {');
X        writeln(tab2, 'if ((*p2++ & ~ *p1++) != 0)');
X        writeln(tab3, 'return (false);');
X        writeln(tab2, 'i--, j--;');
X        writeln(tab1, '}');
X        writeln(tab1, 'while (j != 0) {');
X        writeln(tab2, 'if (*p2++ != 0)');
X        write(tab3, 'return (');
X        printid(defnams[dfalse]^.lid);
X        writeln(');');
X        writeln(tab2, 'j--;');
X        writeln(tab1, '}');
X        write(tab1, 'return (');
X        printid(defnams[dtrue]^.lid);
X        writeln(');');
X        writeln('}')
X        end;
X    if usemksub then
X        begin
X        writeln;
X        writeln(static, setptyp);
X        writeln('Mksubr(lo, hi, sp)');
X        writeln(tab1, registr, usigned, inttyp, tab1, 'lo, hi;');
X        writeln(tab1, registr, setptyp, tab1, 'sp;');
X        writeln('{');
X        writeln(tab1, registr, inttyp, tab1, 'i, k;');
X        writeln;
X        writeln(tab1, 'if (hi < lo)');
X        writeln(tab2, 'return (sp);');
X        writeln(tab1, 'i = hi / (setbits+1) + 1;');
X        writeln(tab1, 'for (k = *sp + 1; k <= i; k++)');
X        writeln(tab2, 'sp[k] = 0;');
X        writeln(tab1, 'if (*sp < i)');
X        writeln(tab2, '*sp = i;');
X        writeln(tab1, 'for (k = lo; k <= hi; k++)');
X        writeln(tab2, 'sp[k / (setbits+1) + 1] |= ',
X                        '(1 << (k % (setbits+1)));');
X        writeln(tab1, 'return (sp);');
X        writeln('}')
X        end;
X    if useins then
X        begin
X        writeln;
X        writeln(static, setptyp);
X        writeln('Insmem(m, sp)');
X        writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
X        writeln(tab1, registr, setptyp, tab1, 'sp;');
X        writeln('{');
X        writeln(tab1, registr, inttyp, tab1, 'i,');
X        writeln(tab3, tab1, 'j = m / (setbits+1) + 1;');
X        writeln;
X        writeln(tab1, 'if (*sp < j)');
X        writeln(tab2, 'for (i = *sp + 1, *sp = j; i <= *sp; i++)');
X        writeln(tab3, 'sp[i] = 0;');
X        writeln(tab1, 'sp[j] |= (1 << (m % (setbits+1)));');
X        writeln(tab1, 'return (sp);');
X        writeln('}')
X        end;
X    if usesets then
X        begin
X        writeln;
X        writeln(ifndef, 'SETSPACE');
X        writeln(define, 'SETSPACE 256');
X        writeln(endif);
X        writeln(static, setptyp);
X        writeln('Currset(n,sp)');
X        writeln(tab1, inttyp, tab1, 'n;');
X        writeln(tab1, setptyp, tab1, 'sp;');
X        writeln('{');
X        writeln(tab1, static, setwtyp, tab1, 'Space[SETSPACE];');
X        writeln(tab1, static, setptyp, tab1, 'Top = Space;');
X        writeln;
X        writeln(tab1, 'switch (n) {');
X        writeln(tab1, '  case 0:');
X        writeln(tab2, 'Top = Space;');
X        writeln(tab2, 'return (0);');
X        writeln(tab1, '  case 1:');
X        writeln(tab2, 'if (&Space[SETSPACE] - Top <= ',
X                            maxsetrange:1, ') {');
X        writeln(tab3,
X            voidcast, 'fprintf(stderr, "Set-space exhausted\n");');
X        writeln(tab3, 'exit(1);');
X        writeln(tab2, '}');
X        writeln(tab2, '*Top = 0;');
X        writeln(tab2, 'return (Top);');
X        writeln(tab1, '  case 2:');
X        writeln(tab2, 'if (Top <= &sp[*sp])');
X        writeln(tab3, 'Top = &sp[*sp + 1];');
X        writeln(tab2, 'return (sp);');
X        writeln(tab1, '}');
X        writeln(tab1, '/', '* NOTREACHED *', '/');
X        writeln('}')
X        end;
X    if usescpy then
X        begin
X        writeln;
X        writeln(static, voidtyp);
X        writeln('Setncpy(S1, S2, N)');
X        writeln(tab1, registr, setptyp, tab1, 'S1, S2;');
X        writeln(tab1, registr, usigned, inttyp, tab1, 'N;');
X        writeln('{');
X        writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
X        writeln;
X        writeln(tab1, 'N /= sizeof(', setwtyp, ');');
X        writeln(tab1, '*S1++ = --N;');
X        writeln(tab1, 'm = *S2++;');
X        writeln(tab1, 'while (m != 0 && N != 0) {');
X        writeln(tab2, '*S1++ = *S2++;');
X        writeln(tab2, '--N;');
X        writeln(tab2, '--m;');
X        writeln(tab1, '}');
X        writeln(tab1, 'while (N-- != 0)');
X        writeln(tab2, '*S1++ = 0;');
X        writeln('}')
X        end;
X    if usecase then
X        begin
X        writeln;
X        writeln(static, voidtyp);
X        writeln('Caseerror(n)');
X        writeln(tab1, inttyp, tab1, 'n;');
X        writeln('{');
X        writeln(tab1, voidcast,
X            'fprintf(stderr, "Missing case limb: line %d\n", n);');
X        writeln(tab1, 'exit(1);');
X        writeln('}')
X        end;
X    if usemax then
X        begin
X        writeln;
X        writeln(static, inttyp);
X        writeln('Max(m, n)');
X        writeln(tab1, inttyp, tab1, 'm, n;');
X        writeln('{');
X        writeln(tab1, 'if (m > n)');
X        writeln(tab2, 'return (m);');
X        writeln(tab1, 'return (n);');
X        writeln('}')
X        end;
X    if use(dtrunc) then
X        begin
X        writeln(static, inttyp);
X        writeln('Trunc(f)');
X        printid(defnams[dreal]^.lid);
X        writeln(tab1, 'f;');
X        writeln('{');
X        writeln(tab1, 'return f;');
X        writeln('}')
X        end;
X    if use(dround) then
X        begin
X        writeln(static, inttyp);
X        writeln('Round(f)');
X        printid(defnams[dreal]^.lid);
X        writeln(tab1, 'f;');
X        writeln('{');
X        writeln(tab1, xtern, doubletyp, ' floor();');    (* LIB *)
X        writeln(tab1,
X            'return floor(', dblcast, '(0.5+f));');    (* LIB *)
X        writeln('}')
X        end
Xend;    (* emit *)
X
X(*    Initialize all global structures used in translator.        *)
Xprocedure initialize;
X
Xvar    s    : hashtyp;
X    t    : pretyps;
X    d    : predefs;
X
X    (*    Define names in ctable.                    *)
X    procedure defname(cn : cnames; str : keyword);
X
X    label    999;
X
X    var    w    : toknbuf;
X        i    : toknidx;
X
X    begin
X        unpack(str, w, 1);
X        for i := 1 to keywordlen do
X            if w[i] = space then
X                begin
X                w[i] := chr(null);
X                goto 999
X                end;
X        w[keywordlen+1] := chr(null);
X    999:
X        ctable[cn] := saveid(w)
X    end;
X
X    (*    Define predefined identifiers.                *)
X    procedure defid(nt : treetyp; did : predefs; str : keyword);
X
X    label    999;
X
X    var    w    : toknbuf;
X        i    : toknidx;
X        tp, tq,
X        tv    : treeptr;
X
X    begin
X        for i := 1 to keywordlen do
X            if str[i] = space then
X                begin
X                w[i] := chr(null);
X                goto 999
X                end
X            else
X                w[i] := str[i];
X        w[keywordlen+1] := chr(null);
X    999:
X        tp := newid(saveid(w));
X        defnams[did] := tp^.tsym;
X        if nt in [ntype, nfunc, nproc] then
X            begin
X            (* predefined types, procedures and functions
X                are marked with a particular node *)
X            tv := mknode(npredef);
X            tv^.tdef := did;
X            tv^.tobtyp := tnone
X            end
X        else
X            tv := nil; (* predefined constants and variables will
X                    eventually be bound to something *)
X        case nt of
X          nscalar:
X            begin
X            tv := mknode(nscalar);
X            tv^.tscalid := nil;
X            tq := mknode(ntype);
X            tq^.tbind := tv;
X            tq^.tidl := tp;
X            tp := tq
X            end;
X          nconst,
X          ntype,
X          nfield,
X          nvar:
X            begin
X            tq := mknode(nt);
X            tq^.tbind := tv;
X            tq^.tidl := tp;
X            tq^.tattr := anone;
X            tp := tq
X            end;
X          nfunc,
X          nproc:
X            begin
X            tq := mknode(nt);
X            tq^.tsubid := tp;
X            tq^.tsubstmt := tv;
X            tq^.tfuntyp := nil;
X            tq^.tsubpar := nil;
X            tq^.tsublab := nil;
X            tq^.tsubconst := nil;
X            tq^.tsubtype := nil;
X            tq^.tsubvar := nil;
X            tq^.tsubsub := nil;
X            tq^.tscope := nil;
X            tq^.tstat := 0;
X            tp := tq
X            end;
X          nid:
X        end;(* case *)
X        deftab[did] := tp
X    end;    (* defid *)
X
X    (*    Define keywords.                    *)
X    procedure defkey(s : symtyp; w : keyword);
X
X    var    i    : 1 .. keywordlen;
X
X    begin
X        for i := 1 to keywordlen do
X            if w[i] = space then
X                w[i] := chr(null);
X        (* relies on symtyp being sorted *)
X        with keytab[ord(s)] do
X            begin
X            wrd := w;
X            sym := s
X            end;
X    end;
X
X    procedure fixinit(i : strindx);
X
X    var    t    : toknbuf;
X
X    begin
X        gettokn(i, t);
X        t[1] := 'i';
X        puttokn(i, t);
X    end;
X
X    (*    Add a cpu word type description.            *)
X    (*    Parameters lo and hi gives the range of a machine-    *)
X    (*    dependant integer type. Parameter str gives the corres-    *)
X    (*    ponding C-language type-name.                *)
X    procedure defmach(lo, hi : integer; str : machdefstr);
X
X    label    999;
X
X    var    i    : toknidx;
X        w    : toknbuf;
X
X    begin
X        unpack(str, w, 1);
X        if w[machdeflen] <> space then
X            error(ebadmach);
X        for i := machdeflen - 1 downto 1 do
X            if w[i] <> space then
X                begin
X                w[i+1] := chr(null);
X                goto 999
X                end;
X        error(ebadmach);
X    999:
X        if nmachdefs >= maxmachdefs then
X            error(emanymachs);
X        nmachdefs := nmachdefs + 1;
X        with machdefs[nmachdefs] do
X            begin
X            lolim := lo;
X            hilim := hi;
X            typstr := savestr(w)
X            end
X    end;
X
X    procedure initstrstore;
X
X    var    i    : strbcnt;
X
X    begin
X        for i := 1 to maxblkcnt do
X            strstor[i] := nil;
X        new(strstor[0]);
X        strstor[0]^[0] := chr(null);
X        strfree := 1;
X        strleft := maxstrblk
X    end;
X
Xbegin    (* initialize *)
X    lineno := 1;
X    colno := 0;
X
X    initstrstore;
X
X    setlst := nil;
X    setcnt := 0;
X    hexdig := '0123456789ABCDEF';
X
X    symtab := nil;
X    statlvl := 0;
X    maxlevel := -1;
X    enterscope(nil);
X    varno:= 0;
X
X    usenilp := false;
X
X    usesets := false;
X    useunion := false;
X    usediff := false;
X    usemksub := false;
X    useintr := false;
X    usesge := false;
X    usesle := false;
X    usesne := false;
X    useseq := false;
X    usememb := false;
X    useins := false;
X    usescpy := false;
X    usefopn := false;
X    usescan := false;
X    usegetl := false;
X
X    usecase := false;
X    usejmps := false;
X
X    usebool := false;
X
X    usecomp := false;
X    usemax    := false;
X
X    for s := 0 to hashmax do
X        idtab[s] := nil;
X    for d := dabs to dztring do
X        begin
X        deftab[d] := nil;
X        defnams[d] := nil
X        end;
X
X    (* Pascal keywords *)
X    defkey(sand,    'and       ');
X    defkey(sarray,    'array     ');
X    defkey(sbegin,    'begin     ');
X    defkey(scase,    'case      ');
X    defkey(sconst,    'const     ');
X    defkey(sdiv,    'div       ');
X    defkey(sdo,    'do        ');
X    defkey(sdownto,    'downto    ');
X    defkey(selse,    'else      ');
X    defkey(send,    'end       ');
X    defkey(sextern,    externsym);    (* non-standard *)
X    defkey(sfile,    'file      ');
X    defkey(sfor,    'for       ');
X    defkey(sforward,'forward   ');
X    defkey(sfunc,    'function  ');
X    defkey(sgoto,    'goto      ');
X    defkey(sif,    'if        ');
X    defkey(sinn,    'in        ');
X    defkey(slabel,    'label     ');
X    defkey(smod,    'mod       ');
X    defkey(snil,    'nil       ');
X    defkey(snot,    'not       ');
X    defkey(sof,    'of        ');
X    defkey(sor,    'or        ');
X    defkey(sother,    othersym);    (* non-standard *)
X    defkey(spacked,    'packed    ');
X    defkey(sproc,    'procedure ');
X    defkey(spgm,    'program   ');
X    defkey(srecord,    'record    ');
X    defkey(srepeat,    'repeat    ');
X    defkey(sset,    'set       ');
X    defkey(sthen,    'then      ');
X    defkey(sto,    'to        ');
X    defkey(stype,    'type      ');
X    defkey(suntil,    'until     ');
X    defkey(svar,    'var       ');
X    defkey(swhile,    'while     ');
X    defkey(swith,    'with      ');
X    defkey(seof,    dummysym);    (* dummy entry *)
X
X    (* C language operator priorities *)
X    cprio[nformat]    := 0;
X    cprio[nrange]    := 0;
X    cprio[nin]    := 0;
X    cprio[nset]    := 0;
X    cprio[nassign]    := 0;
X    cprio[nor]    := 1;
X    cprio[nand]    := 2;
X    cprio[neq]    := 3;
X    cprio[nne]    := 3;
X    cprio[nlt]    := 3;
X    cprio[nle]    := 3;
X    cprio[ngt]    := 3;
X    cprio[nge]    := 3;
X    cprio[nplus]    := 4;
X    cprio[nminus]    := 4;
X    cprio[nmul]    := 5;
X    cprio[ndiv]    := 5;
X    cprio[nmod]    := 5;
X    cprio[nquot]    := 5;
X    cprio[nnot]    := 6;
X    cprio[numinus]    := 6;
X    cprio[nuplus]    := 7;
X    cprio[nindex]    := 7;
X    cprio[nselect]    := 7;
X    cprio[nderef]    := 7;
X    cprio[ncall]    := 7;
X    cprio[nid]    := 7;
X    cprio[nchar]    := 7;
X    cprio[ninteger]    := 7;
X    cprio[nreal]    := 7;
X    cprio[nstring]    := 7;
X    cprio[nnil]    := 7;
X
X    (* Pascal language operator priorities *)
X    pprio[nassign]    := 0;
X    pprio[nformat]    := 0;
X    pprio[nrange]    := 1;
X    pprio[nin]    := 1;
X    pprio[neq]    := 1;
X    pprio[nne]    := 1;
X    pprio[nlt]    := 1;
X    pprio[nle]    := 1;
X    pprio[ngt]    := 1;
X    pprio[nge]    := 1;
X    pprio[nor]    := 2;
X    pprio[nplus]    := 2;
X    pprio[nminus]    := 2;
X    pprio[nand]    := 3;
X    pprio[nmul]    := 3;
X    pprio[ndiv]    := 3;
X    pprio[nmod]    := 3;
X    pprio[nquot]    := 3;
X    pprio[nnot]    := 4;
X    pprio[numinus]    := 4;
X    pprio[nuplus]    := 5;
X    pprio[nset]    := 6;
X    pprio[nindex]    := 6;
X    pprio[nselect]    := 6;
X    pprio[nderef]    := 6;
X    pprio[ncall]    := 6;
X    pprio[nid]    := 6;
X    pprio[nchar]    := 6;
X    pprio[ninteger]    := 6;
X    pprio[nreal]    := 6;
X    pprio[nstring]    := 6;
X    pprio[nnil]    := 6;
X
X    (* table of C keywords/functions (which Pascal doesn't know about) *)
X    defname(cabort,        'abort     ');    (* OS *)
X    defname(cbreak,        'break     ');
X    defname(ccontinue,    'continue  ');
X    defname(cdefine,    'define    ');
X    defname(cdefault,    'default   ');
X    defname(cdouble,    'double    ');
X    defname(cedata,        'edata     ');    (* OS *)
X    defname(cenum,        'enum      ');
X    defname(cetext,        'etext     ');    (* OS *)
X    defname(cextern,    'extern    ');
X    defname(cfclose,    'fclose    ');    (* LIB *)
X    defname(cfflush,    'fflush    ');    (* LIB *)
X    defname(cfgetc,        'fgetc     ');    (* LIB *)
X    defname(cfloat,        'float     ');
X    defname(cfloor,        'floor     ');    (* OS *)
X    defname(cfprintf,    'fprintf   ');    (* LIB *)
X    defname(cfputc,        'fputc     ');    (* LIB *)
X    defname(cfread,        'fread     ');    (* LIB *)
X    defname(cfscanf,    'fscanf    ');    (* LIB *)
X    defname(cfwrite,    'fwrite    ');    (* LIB *)
X    defname(cgetc,        'getc      ');    (* OS *)
X    defname(cgetpid,    'getpid    ');    (* OS *)
X    defname(cint,        'int       ');
X    defname(cinclude,    'include   ');
X    defname(clong,        'long      ');
X    defname(clog,        'log       ');    (* OS *)
X    defname(cmain,        'main      ');
X    defname(cmalloc,    'malloc    ');    (* LIB *)
X    defname(cprintf,    'printf    ');    (* LIB *)
X    defname(cpower,        'pow       ');    (* OS *)
X    defname(cputc,        'putc      ');    (* LIB *)
X    defname(cread,        'read      ');    (* OS *)
X    defname(creturn,    'return    ');
X    defname(cregister,    'register  ');
X    defname(crewind,    'rewind    ');    (* LIB *)
X    defname(cscanf,        'scanf     ');    (* LIB *)
X    defname(csetbits,    'setbits   ');
X    defname(csetword,    'setword   ');
X    defname(csetptr,    'setptr    ');
X    defname(cshort,        'short     ');
X    defname(csigned,    'signed    ');
X    defname(csizeof,    'sizeof    ');
X    defname(csprintf,    'sprintf   ');    (* LIB *)
X    defname(cstatic,    'static    ');
X    defname(cstdin,        'stdin     ');    (* LIB *)
X    defname(cstdout,    'stdout    ');    (* LIB *)
X    defname(cstderr,    'stderr    ');    (* LIB *)
X    defname(cstrncmp,    'strncmp   ');    (* OS *)
X    defname(cstrncpy,    'strncpy   ');    (* OS *)
X    defname(cstruct,    'struct    ');
X    defname(cswitch,    'switch    ');
X    defname(ctypedef,    'typedef   ');
X    defname(cundef,        'undef     ');
X    defname(cungetc,    'ungetc    ');    (* LIB *)
X    defname(cunion,        'union     ');
X    defname(cunlink,    'unlink    ');    (* OS *)
X    defname(cunsigned,    'unsigned  ');
X    defname(cwrite,        'write     ');    (* OS *)
X
X    (* create predefined identifiers *)
X    defid(nfunc,    dabs,        'abs       ');
X    defid(nfunc,    darctan,    'arctan    ');
X    defid(nvar,    dargc,        'argc      ');    (* OS *)
X    defid(nproc,    dargv,        'argv      ');    (* OS *)
X    defid(nscalar,    dboolean,    'boolean   ');
X    defid(ntype,    dchar,        'char      ');
X    defid(nfunc,    dchr,        'chr       ');
X    defid(nproc,    dclose,        'close     ');    (* OS *)
X    defid(nfunc,    dcos,        'cos       ');
X    defid(nproc,    ddispose,    'dispose   ');
X    defid(nid,    dfalse,        'false     ');
X    defid(nfunc,    deof,        'eof       ');
X    defid(nfunc,    deoln,        'eoln      ');
X    defid(nproc,    dexit,        'exit      ');    (* OS *)
X    defid(nfunc,    dexp,        'exp       ');
X    defid(nproc,    dflush,        'flush     ');    (* OS *)
X    defid(nproc,    dget,        'get       ');
X    defid(nproc,    dhalt,        'halt      ');    (* OS *)
X    defid(nvar,    dinput,        'input     ');
X    defid(ntype,    dinteger,    'integer   ');
X    defid(nfunc,    dln,        'ln        ');
X    defid(nconst,    dmaxint,    'maxint    ');
X    defid(nproc,    dmessage,    'message   ');    (* OS *)
X    defid(nproc,    dnew,        'new       ');
X    defid(nfunc,    dodd,        'odd       ');
X    defid(nfunc,    dord,        'ord       ');
X    defid(nvar,    doutput,    'output    ');
X    defid(nproc,    dpack,        'pack      ');
X    defid(nproc,    dpage,        'page      ');
X    defid(nfunc,    dpred,        'pred      ');
X    defid(nproc,    dput,        'put       ');
X    defid(nproc,    dread,        'read      ');
X    defid(nproc,    dreadln,    'readln    ');
X    defid(ntype,    dreal,        'real      ');
X    defid(nproc,    dreset,        'reset     ');
X    defid(nproc,    drewrite,    'rewrite   ');
X    defid(nfunc,    dround,        'round     ');
X    defid(nfunc,    dsin,        'sin       ');
X    defid(nfunc,    dsqr,        'sqr       ');
X    defid(nfunc,    dsqrt,        'sqrt      ');
X    defid(nfunc,    dsucc,        'succ      ');
X    defid(ntype,    dtext,        'text      ');
X    defid(nid,    dtrue,        'true      ');
X    defid(nfunc,    dtrunc,        'trunc     ');
X    defid(nfunc,    dtan,        'tan       ');
X    defid(nproc,    dunpack,    'unpack    ');
X    defid(nproc,    dwrite,        'write     ');
X    defid(nproc,    dwriteln,    'writeln   ');
X
X    defid(nfield,    dzinit,        '$nit      ');    (* for internal use *)
X    defid(ntype,    dztring,    '$ztring   ');
X
X    (* bind constants and variables *)
X    deftab[dboolean]^.tbind^.tscalid := deftab[dfalse];
X    deftab[dfalse]^.tnext := deftab[dtrue];
X    currsym.st := sinteger;
X    currsym.vint := maxint;
X    deftab[dmaxint]^.tbind := mklit;
X    deftab[dargc]^.tbind := deftab[dinteger]^.tbind;
X    deftab[dinput]^.tbind := deftab[dtext]^.tbind;
X    deftab[doutput]^.tbind := deftab[dtext]^.tbind;
X
X    for t := tnone to terror do
X        begin
X        (* for predefined types: set up pointers to "npredef" nodes
X           describing type, fill in constant identifying type *)
X        case t of
X          tboolean:
X            typnods[t] := deftab[dboolean]; (* scalar type *)
X          tchar:
X            typnods[t] := deftab[dchar]^.tbind;
X          tinteger:
X            typnods[t] := deftab[dinteger]^.tbind;
X          treal:
X            typnods[t] := deftab[dreal]^.tbind;
X          ttext:
X            typnods[t] := deftab[dtext]^.tbind;
X          tstring:
X            typnods[t] := deftab[dztring]^.tbind;
X          tnil,
X          tset,
X          tpoly,
X          tnone:
X            typnods[t] := mknode(npredef);
X          terror:
X            (* no op *)
X        end;(* case *)
X        if t in [tchar, tinteger, treal, ttext, tnone, tpoly,
X                        tstring, tnil, tset] then
X            typnods[t]^.tobtyp := t
X        end;
X
X    (* fix name and type of field "init" *)
X    fixinit(defnams[dzinit]^.lid^.istr);
X    deftab[dzinit]^.tbind := deftab[dinteger]^.tbind;
X
X    for d := dabs to dztring do
X        linkup(nil, deftab[d]);
X
X    deftab[dchr]^.tfuntyp := typnods[tchar];
X
X    deftab[deof]^.tfuntyp := typnods[tboolean];
X    deftab[deoln]^.tfuntyp := typnods[tboolean];
X    deftab[dodd]^.tfuntyp := typnods[tboolean];
X
X    deftab[dord]^.tfuntyp := typnods[tinteger];
X    deftab[dround]^.tfuntyp := typnods[tinteger];
X    deftab[dtrunc]^.tfuntyp := typnods[tinteger];
X
X    deftab[darctan]^.tfuntyp := typnods[treal];
X    deftab[dcos]^.tfuntyp := typnods[treal];
X    deftab[dsin]^.tfuntyp := typnods[treal];
X    deftab[dtan]^.tfuntyp := typnods[treal];
X    deftab[dsqrt]^.tfuntyp := typnods[treal];
X    deftab[dexp]^.tfuntyp := typnods[treal];
X    deftab[dln]^.tfuntyp := typnods[treal];
X
X    deftab[dsqr]^.tfuntyp := typnods[tpoly];
X    deftab[dabs]^.tfuntyp := typnods[tpoly];
X    deftab[dpred]^.tfuntyp := typnods[tpoly];
X    deftab[dsucc]^.tfuntyp := typnods[tpoly];
X
X    deftab[dargv]^.tfuntyp := typnods[tnone];
X    deftab[ddispose]^.tfuntyp := typnods[tnone];
X    deftab[dexit]^.tfuntyp := typnods[tnone];
X    deftab[dget]^.tfuntyp := typnods[tnone];
X    deftab[dhalt]^.tfuntyp := typnods[tnone];
X    deftab[dnew]^.tfuntyp := typnods[tnone];
X    deftab[dpack]^.tfuntyp := typnods[tnone];
X    deftab[dput]^.tfuntyp := typnods[tnone];
X    deftab[dread]^.tfuntyp := typnods[tnone];
X    deftab[dreadln]^.tfuntyp := typnods[tnone];
X    deftab[dreset]^.tfuntyp := typnods[tnone];
X    deftab[drewrite]^.tfuntyp := typnods[tnone];
X    deftab[dwrite]^.tfuntyp := typnods[tnone];
X    deftab[dwriteln]^.tfuntyp := typnods[tnone];
X    deftab[dmessage]^.tfuntyp := typnods[tnone];
X    deftab[dunpack]^.tfuntyp := typnods[tnone];
X
X    (* set up definitions for integer subranges *)
X    nmachdefs := 0;
X    defmach(0,        255,        'unsigned char   '); (* CPU *)
X    defmach(-128,        127,        'char            '); (* CPU *)
X    defmach(0,        65535,        'unsigned short  '); (* CPU *)
X    defmach(-32768,        32767,        'short           '); (* CPU *)
X    defmach(-2147483647,    2147483647,    'long            '); (* CPU *)
X{    defmach(0,        4294967295,    'unsigned long   ');}(* CPU *)
Xend;    (* initialize *)
X
Xprocedure exit(i : integer); external;    (* OS *)
X
X(*    Action to take when an error is detected.            *)
Xprocedure error;
X
Xbegin
X    prtmsg(m);
X    exit(1);    (* OS *)
X    goto 9999
Xend;
X
X(*    Action to take when a fatal error is detected.            *)
Xprocedure fatal;
X
Xbegin
X    prtmsg(m);
X    halt        (* OS *)
X    (* goto 9999    *)
Xend;
X
X
Xbegin    (* program *)
X    initialize;
X    if echo then
X        writeln('# ifdef PASCAL');
X    parse;
X    if echo then
X        writeln('# else');
X    lineno := 0; lastline := 0;
X    transform;
X    emit;
X    if echo then
X        writeln('# endif');
X9999:
X    (* the very *)
Xend.
X
END_OF_FILE
if test 54467 -ne `wc -c <'ptc.p.4'`; then
    echo shar: \"'ptc.p.4'\" unpacked with wrong size!
fi
# end of 'ptc.p.4'
fi
echo shar: End of archive 11 \(of 12\).
cp /dev/null ark11isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 12 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]